perm filename WLDMOD.SAI[HAL,HE]3 blob
sn#200981 filedate 1976-02-12 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00021 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002
C00004 00003 SIMPLE PROCEDURE STITINI
C00005 00004 ! fluent_fact
C00006 00005 ! csplit, stmchk, is_undef_sym_item
C00008 00006 ! world assignment: xxxwld, wldasg (lpbasg, parasg)
C00014 00007 ! check_guards
C00015 00008 ! mergein
C00016 00009 ! cpattl
C00018 00010 ! asrtit & denyit
C00021 00011 ! new_exprn, stmake, new_stmnt, new_gassign, new_alsodo
C00026 00012 ! younger,afxdget
C00029 00013 ! controllable
C00032 00014 ! dexprset, domove
C00038 00015 ! do_affix, do_affix_stmnt, do_unfix
C00043 00016 ! blockdo & sttblk, blkopdo
C00046 00017 ! Cobdo
C00047 00018 ! loopbdo
C00048 00019 ! statement interpreter: stinterp (owdo, iwcopy)
C00055 00020 ifcr false thenc ! proc_form interpreter: apfrm, apfrm2
C00057 00021 ! test program
C00058 ENDMK
C⊗;
IFCR ¬DECLARATION(EXTENDED_COMPILATION) THENC
ENTRY;
BEGIN "WLDMOD"
IFCR ¬DECLARATION(CREFFING) THENC DEFINE CREFFING = FALSE;ENDC
IFCR ¬ CREFFING THENC
REQUIRE "HALREQ.HDR[HAL,HE]" SOURCE_FILE;
ENDC
DEFINE $$PRGID "[]" = ["WLDMOD"];
ENDC
REQUIRE 300 SYSTEM_PDL;
INTEGER STITRC;
RPTR(SPECVAL) VNEWTRANS;
PROCEDURE VNEWINI;
BEGIN
VNEWTRANS←NEW_RECORD(SPECVAL);
SPECVAL:TYPE[VNEWTRANS]←TRANS_DTYPE;
END;
REQUIRE VNEWINI INITIALIZATION;
RPTR(BLOCK) CURBLK; ! id of current block in stinterp;
SIMPLE PROCEDURE STITINI;
BEGIN
OUTSTR("
SET TRACE OPTIONS FOR STINTERP:
'1 -- print ""statement"" type
'2 -- print ""statement"" record
type in one fhq octal number:");
STITRC←CVO(INCHWL);
END;
! fluent_fact;
BOOLEAN PROCEDURE FLUENT_FACT(RPTR(FACT) F);
BEGIN
RANY PTN;
PTN←FACT:PATT[F];
IF RECLEN(PTN)≠2 THEN RETURN(FALSE);
START_CODE "FLFSTC"
LABEL XXX,XXX0;
SKIPE 1,PTN;
SKIPN 1,1(1);
JRST XXX;
TLC 1,REC_CODE;
TLNE 1,(PROCB+ARY2B+ITEMB+'3740);
JRST XXX0; ! false if first isn't ref(record);
HRRZ 1,(1); ! point at record;
HRRZ 1,(1); ! point at record type;
CAIN 1,FLUENT;
XXX0: TDZA 1,1;
MOVEI 1,1;
XXX: END;
END;
! csplit, stmchk, is_undef_sym_item;
SIMPLE ITEMVAR PROCEDURE CSPLIT(ITEMVAR IW;BOOLEAN NEWFG(TRUE));
RETURN(IF NEWFG THEN NEWWLD ELSE IW);
! be sure S is a statement;
RPTR(STMNT) PROCEDURE STMCHK(RANY S);
RETURN(CHKREC(S,LOC(STMNT)));
! world assignment: xxxwld, wldasg (lpbasg, parasg);
SIMPLE ITEMVAR PROCEDURE XXXWLD(ITEMVAR INW;BOOLEAN CLANY(FALSE));
BEGIN
! Makes a copy of the input world and returns it. If CLANY
is TRUE, then the "clear" field of the new world is set to
ANY. Otherwise, it is copied from the old world.;
ITEMVAR OUW;
OUW←NEWWLD;
CLEAR[WLDINX(OUW)]←IF CLANY THEN ANY ELSE CLEAR[WLDINX(INW)];
COPY_ALERTS(INW,OUW);
RETURN(OUW);
END;
INTERNAL RECURSIVE PROCEDURE WLDASG(RPTR(STMNT) S;
ITEMVAR IW;REFERENCE ITEMVAR OW;REFERENCE BOOLEAN NFLAG);
BEGIN
! Assigns worlds to statements associated with the statement
S. If NFLAG is true, then something or other special
happens. (This flag is used to avoid assigning separate
worlds to successive assignment statements).
No longer makes the variable list for blocks.
;
LABEL XIT;
RANY SS;
INTEGER ST;
RCELL C;
BOOLEAN NF;
RECPROC LPBASG(RPTR(STMNT) SS);
BEGIN
! Handles the special case of a loop body;
ITEMVAR IWW,WW;
IF SS = RNULL THEN RETURN;
NF←TRUE;
IWW←XXXWLD(IW,TRUE);
WW←PREP_ALERT(IWW);
CLEAR[WLDINX(IWW)]←WW;
WLDASG(SS,IWW,OW,NF);
OW←XXXWLD(IW);
END;
RECPROC PARASG(RCELL C);
BEGIN
! CDRs down a list of statements that are meant to be
parallel in execution, doing the world assignments.
Assigns a world to the end as well;
WHILE C≠NULL_RECORD DO
BEGIN
NF←TRUE;
WLDASG(STMCHK(CELL:CAR[C]),XXXWLD(IW,TRUE),OW,NF);
C←CELL:CDR[C];
END;
OW←XXXWLD(IW);
END;
SS←STMNT:SEMANTICS[S];
ST←RECTYPE(SS);
STMNT:IW[S]←IW;
IF ST=0 ∨ ST =LOC(COMMNT) THEN
BEGIN
OW←STMNT:OW[S]←IW;
RETURN;
END;
IF ST=LOC(ASSERT)∨ST=LOC(DENY) THEN
BEGIN
IF ASSERT:WLD[SS]≠ANY THEN
BEGIN
OW←IW;
END
ELSE
BEGIN
OW←IF NFLAG THEN XXXWLD(IW) ELSE IW;
ASSERT:WLD[SS]←OW;
NFLAG←FALSE;
END;
STMNT:OW[S]←OW;
RETURN;
END
ELSE IF ST=LOC(ASSIGNMENT)∨ST=LOC(GASSIGN) THEN
BEGIN
OW←STMNT:OW[S]←IF NFLAG THEN XXXWLD(IW) ELSE IW;
NFLAG←FALSE;
RETURN;
END
ELSE
NFLAG←TRUE;
NF←TRUE;
IF ST=LOC(BLOCK) THEN
BEGIN "blkasg"
RPTR(BLOCK) B;
B←SS;
C←BLOCK:CODE[B];
OW←IW;
WHILE C≠NULL_RECORD DO
BEGIN
SS←CELL:CAR[C];
ST←RECTYPE(SS);
IF ST=LOC(PVL)∨ST=LOC(DBD) THEN
BEGIN
END
ELSE IF ST=LOC(VARIABLE) THEN
BEGIN
END
ELSE IF ST=LOC(STMNT) THEN
BEGIN "sasa"
WLDASG(SS,OW,OW,NF);
END;
C←CELL:CDR[C];
END;
! **** perhaps will want to give blocks their own variables ****;
END
ELSE IF ST=LOC(COBLOCK) THEN
BEGIN
PARASG(COBLOCK:CODE[SS]);
END
ELSE IF ST=LOC(FORR) THEN
LPBASG(FORR:BODY[SS])
ELSE IF ST=LOC(WHIL) THEN
LPBASG(WHIL:BODY[SS])
ELSE IF ST=LOC(IFF) THEN
BEGIN
NF←TRUE;
WLDASG(IFF:THN[SS],XXXWLD(IW,TRUE),OW,NF);
NF←TRUE;
WLDASG(IFF:ELS[SS],XXXWLD(IW,TRUE),OW,NF);
OW←XXXWLD(IW);
END
ELSE IF ST=LOC(NW) THEN
BEGIN
NFLAG←FALSE;
OW←NW:WLD[SS];
IF OW=ANY THEN
OW←XXXWLD(IW)
ELSE
BEGIN
CLEAR[WLDINX(OW,-1)]←CLEAR[WLDINX(IW)];
COPY_ALERTS(IW,OW);
END;
END
ELSE IF ST=LOC(PROG) THEN
BEGIN
! **** Not sure what to do here with NFLAG & NF ****;
WLDASG(PROG:CODE[SS],XXXWLD(IW,TRUE),OW,NF);
END
ELSE
OW←XXXWLD(IW);
STMNT:OW[S]←OW;
XIT: END;
! check_guards;
PROCEDURE CHECK_GUARDS(ITEMVAR IW,OW);
BEGIN
RPTR(FACT) F;
INTEGER OWX;
ITEMVAR GW,WW;
∀ WW | ALERT_ORDER⊗IW≡WW DO
BEGIN
GW←GUARD[WLDINX(WW)];
IF GW=ANY THEN CONTINUE;
∀ | GEN_FACTS(F,GW) DO
BEGIN
IF ¬TSTWIX(F,OWX) THEN
BEGIN
$PRINT(CRLF&"WARNING: ",TTYALWAYS);
PRNREC(FACT:PATT[F],TTYALWAYS);
$PRINT(" WAS ASSUMED TO BE TRUE, BUT MAY NOT BE"
&CRLF,TTYALWAYS);
END;
END;
END;
END;
! mergein;
PROCEDURE MERGEIN(ITEMVAR IW,OW);
BEGIN
RPTR(FACT) F;
INTEGER IWX,OWX;
IWX←WLDINX(IW);OWX←WLDINX(OW);
∀ | GEN_FACTS(F,OW) DO
BEGIN
IF ¬TSTWIX(F,IWX)∧FLUENT_FACT(F) THEN
CLRWLD(F,OWX);
END;
∀ | GEN_FACTS(F,IW) DO
BEGIN
IF ¬TSTWIX(F,OWX)∧¬FLUENT_FACT(F) THEN
SETWLD(F,OWX);
END;
END;
! cpattl;
LIST PROCEDURE CPATTL(RCELL C;ITEMVAR WLD;REFERENCE RCELL BL);
BEGIN
RANY V;
ITEMVAR IV;
INTEGER VTYP;
LIST PL;
BL←NULL_RECORD;
PL←NIL;
WHILE C≠NULL_RECORD DO
BEGIN "CLOOP"
V←CELL:CAR[C];
VTYP←RECTYPE(V);
IF VTYP=LOC(NOMV) THEN
BEGIN
! fetch nominal value;
V←EVALEXPR(V,WLD);
END
ELSE IF VTYP=LOC(BINDV) THEN
BEGIN
BL←CONS(V,BL);
IV←\(BINDV:RESULT[V])[1];
∂(IV,INTEGER)←∂(IV,INTEGER) LOR BINDB;
! **** BECAUSE OF A SAIL LOSSAGE *****;
PL[∞+1]←IV;
CONTINUE "CLOOP";
END
ELSE IF VTYP≠LOC(VARIABLE) THEN
USERERR(1,1,"CPATTL DOESN'T EXPECT AN ELEMENT OF TYPE "
&CVRTS(VTYP));
PL←PL&\($ V);
C←CELL:CDR[C];
END;
RETURN(PL);
END;
! asrtit & denyit;
INTERNAL PROCEDURE ASRTIT(RPTR(AFACT,SFACT) F;ITEMVAR IW,OW);
BEGIN
RCELL CC;
IF RECTYPE(F)=LOC(AFACT) THEN
BEGIN
RPTR(EXPRN,VARIABLE) L;
L←AFACT:LEFT[F];
IF RECTYPE(L)≠LOC(VARIABLE)∨AFACT:RELN[F]≠0 THEN
BEGIN
$PRINT(CRLF,TTYYES);
HALPRN(F,TTYYES);
USERERR(1,1," asrtit given an afact it cannot handle"&crlf);
RETURN;
END
ELSE
VCHANGE(L,EVALEXPR(AFACT:RIGHT[F],IW),OW);
END
ELSE IF RECTYPE(F)=LOC(SFACT) THEN
BEGIN "SASSERT"
LPASRT(OW,CPATTL(SFACT:PATT[F],IW,CC));
IF CC≠NULL_RECORD THEN
USERERR(1,1,"BINDING ASSERTIT??");
END
ELSE
USERERR(1,1,"ASRTIT CALLED WITH FUNNY FACT");
END;
INTERNAL PROCEDURE DENYIT(RPTR(SFACT,AFACT) F;ITEMVAR IW,OW);
BEGIN
RANY CC;
IF RECTYPE(F)=LOC(AFACT) THEN
BEGIN
RPTR(EXPRN,VARIABLE) L;
L←AFACT:LEFT[F];
IF RECTYPE(L)≠LOC(VARIABLE)∨AFACT:RELN[F]≠0 THEN
BEGIN
$PRINT(CRLF,TTYYES);
HALPRN(F,TTYYES);
USERERR(1,1," denyit given an afact it cannot handle"&crlf);
RETURN;
END
ELSE
BEGIN
IF EXPEQV(EVALEXPR(L,IW),EVALEXPR(AFACT:RIGHT[F],IW)) THEN
INVALIDATE(L,OW);
END;
END
ELSE IF RECTYPE(F)=LOC(SFACT) THEN
BEGIN "SDENY"
LPDENY(OW,CPATTL(SFACT:PATT[F],IW,CC));
IF CC≠NULL_RECORD THEN
USERERR(1,1," binding denyit?? ");
END
ELSE
USERERR(1,1,"DENYIT CALLED WITH FUNNY FACT");
END;
! new_exprn, stmake, new_stmnt, new_gassign, new_alsodo;
INTERNAL RPTR(EXPRN) PROCEDURE NEW_EXPRN(INTEGER DT,OP;RCELL ARGS);
BEGIN
RPTR(EXPRN) E;
E←NEW_RECORD(EXPRN);
EXPRN:DATATYPE[E]←DT;
EXPRN:OP[E]←OP;
EXPRN:ARGS[E]←ARGS;
RETURN(E);
END;
INTERNAL RPTR(STMNT) PROCEDURE STMAKE(RSSS SEM(NULL_RECORD));
BEGIN
RPTR(STMNT) S;
S←NEW_RECORD(STMNT);
STMNT:SEMANTICS[S]←SEM;
STMNT:ID[S]←NEW(S);
RETURN(S);
END;
INTERNAL RPTR(STMNT) PROCEDURE NEW_STMNT(ITEMVAR IW,OW; RSSS SEM);
BEGIN
RPTR(STMNT) S;
S←STMAKE(SEM);
STMNT:IW[S]←IW;
STMNT:OW[S]←OW;
RETURN(S);
END;
INTERNAL RPTR(GASSIGN) PROCEDURE NEW_GASSIGN(RVAR V;INTEGER OP;
RPTR(CALCULATOR) C);
BEGIN
RPTR(GASSIGN) GA;
GA←NEW_RECORD(GASSIGN);
GASSIGN:VAR[GA]←V;
GASSIGN:OP[GA]←OP;
GASSIGN:CLC[GA]←C;
RETURN(GA);
END;
INTERNAL RPTR(ALSODO) PROCEDURE NEW_ALSODO(RVAR V;INTEGER OP;
RPTR(CHANGER) C);
BEGIN
RPTR(ALSODO) ADO;
ADO←NEW_RECORD(ALSODO);
ALSODO:VAR[ADO]←V;
ALSODO:OP[ADO]←OP;
ALSODO:CHG[ADO]←C;
RETURN(ADO);
END;
! younger,afxdget;
RPTR(VARIABLE) PROCEDURE YOUNGER(RPTR(VARIABLE) V1,V2);
BEGIN
RPTR(BLOCK) B1,B2;
B1←VARIABLE:BLK[V1];B2←VARIABLE:BLK[V2];
IF B1=NULL_RECORD THEN RETURN(V2);
IF B2=NULL_RECORD THEN RETURN(V1);
DO BEGIN
IF B1=B2 THEN RETURN(V1);
B1←BLOCK:PARENT[B1];
END UNTIL B1=NULL_RECORD;
B1←VARIABLE:BLK[V1];
DO BEGIN
IF B1=B2 THEN RETURN(V2);
B2←BLOCK:PARENT[B2];
END UNTIL B2=NULL_RECORD;
BUG("CANNOT TELL WHICH IS YOUNGER");
RETURN(V1); ! arbitrary;
END;
RCELL AFXDLIS;
RPTR(AFXDATA) PROCEDURE AFXDGET(RVAR A,B;RPTR(VARIABLE,EXPRN) TT;BOOLEAN MAKENEW);
BEGIN
RCELL C;
RVAR T;
RPTR(AFXDATA) AD;
IF RECTYPE(TT)=LOC(EXPRN) THEN
BEGIN
IF EXPRN:OP[TT]≠TINVRT_OP THEN
BUG("FUNNY EXPRESSION TO AFXGET")
ELSE
T←CHKREC(CELL:CAR[EXPRN:ARGS[TT]],LOC(VARIABLE));
END
ELSE
T←TT;
IF VARIABLE:DATATYPE[T]≠TRANS_DTYPE THEN
BUG("FUNNY BY VARIABLE TO AFXDGET");
C←AFXDLIS;
WHILE C≠NULL_RECORD DO
BEGIN
AD←LLOP(C);
IF AFXDATA:A[AD]=A∧AFXDATA:B[AD]=B∧AFXDATA:T[AD]=T THEN
RETURN(AD);
END;
IF ¬MAKENEW∨TT≠T THEN
BUG("COULDN'T FIND AFX DATA");
AD←NEW_RECORD(AFXDATA);
AFXDATA:A[AD]←A;AFXDATA:B[AD]←B;AFXDATA:T[AD]←T;
AFXDATA:YOUNGEST[AD]←YOUNGER(A,YOUNGER(B,T));
RETURN(CONSON(AD,AFXDLIS));
END;
! controllable;
BOOLEAN RECPROC CONTROLLABLE(ITEMVAR WLD;RVAR A;
REFERENCE RVAR CF;REFERENCE REXPR BYEXP;
REFERENCE SET SEEN);
BEGIN
RVAR N,RGF;
RPTR(VARIABLE,EXPRN) BYE;
RPTR(EXPRN) E;
IF A=BARM ∨ A=YARM THEN
BEGIN
BYEXP←NULL_RECORD;CF←A;
RETURN(TRUE);
END;
PUT VARIABLE:NAME[A] IN SEEN;
∀ | LPMATCH(WLD,\(AFFIXED,$ A,BIND N,BIND BYE,BIND RGF)) DO
BEGIN
IF VARIABLE:NAME[N] ε SEEN THEN CONTINUE;
IF CONTROLLABLE(WLD,N,CF,E,SEEN) THEN
BEGIN
IF E=NULL_RECORD THEN
BYEXP←BYE
ELSE
BYEXP←NEW_EXPRN(TRANS_DTYPE,
TTMUL_OP,LIST2(E,BYE));
RETURN(TRUE);
END;
END;
RETURN(FALSE);
END;
! dexprset, domove;
PROCEDURE DEXPRSET(RPTR(DEXPR) DE;REXPR DX,TX;
INTEGER DATATYPE;
ITEMVAR WLD);
BEGIN
! DX is destination expression from MOVE statement.
TX is correction from affixment structure.
Actual destination should be DE*inv(TX).
Computes planning value in WLD & puts away in
VAL[DE]. Also, puts planning value away into VAR[DE]
via a call to VCHANGE.
;
IF TX≠NULL_RECORD THEN
BEGIN
IF DATATYPE=FRAME_DTYPE THEN
DX ← NEW_EXPRN(TRANS_DTYPE,TTMUL_OP,
LIST2(DX,INVSIMP(NEW_EXPRN(TRANS_DTYPE,TINVRT_OP,
CONS(TX,NULL_RECORD))) ))
ELSE
BUG("DEXPRTYPE CANNOT HANDLE DATATYPE ");
END;
IF RECTYPE(DX)≠LOC(VARIABLE) THEN
BEGIN
IF DEXPR:TMPVAR[DE]≠NULL_RECORD THEN
BEGIN
IF VARIABLE:DATATYPE[DEXPR:TMPVAR[DE]]≠DATATYPE THEN
BUG("WARNING: INCOMPATIBLE TYPES IN USE OF TEMP");
END
ELSE
DEXPR:TMPVAR[DE]←NEW_VAR(NEW(NULL_RECORD),DATATYPE,CURBLK);
DEXPR:VAR[DE]←DEXPR:TMPVAR[DE];
DEXPR:EXPN[DE]←DX;
END
ELSE
BEGIN
DEXPR:VAR[DE]←DEXPR:EXPN[DE]←DX;
END;
DEXPR:VAL[DE]←EVALEXPR(DX,WLD);
VCHANGE(DEXPR:VAR[DE],DEXPR:VAL[DE],WLD);
END;
RECURSIVE PROCEDURE DOMOVE(RPTR(STMNT) S);
BEGIN
RPTR(EXPRN) E;
SET SEEN;
RCELL C;
RANY ONM;
RPTR(MOVE$) MS;
INTEGER DT;
ITEMVAR IW,OW;
IW←STMNT:IW[S];OW←STMNT:OW[S];
CPYWLD(IW,OW);
MS ← STMNT:SEMANTICS[S]; ! Added by RF;
SEEN←PHI;
IF MOVE$:WHAT[MS]=YHAND ∨ MOVE$:WHAT[MS]=BHAND THEN
BEGIN ! OK, Ray, you win. But this is a kluge;
E ← NULL_RECORD;
DT←SVAL_DTYPE;
MOVE$:CF[MS] ← MOVE$:WHAT[MS];
END
ELSE
BEGIN
DT←FRAME_DTYPE;
IF ¬CONTROLLABLE(OW,MOVE$:WHAT[MS],MOVE$:CF[MS],E,SEEN) THEN
BUG("MOVE MUST HAVE A CONTROLLABLE FRAME");
END;
DEXPRSET(MOVE$:DEXP[MS],MOVE$:DEST[MS],E,DT,OW);
VCHANGE(MOVE$:CF[MS],DEXPR:VAL[MOVE$:DEXP[MS]],OW);
C←MOVE$:CLAUSES[MS];
WHILE C≠NULL_RECORD DO
BEGIN
RANY X;INTEGER RT;
X←LLOP(C);
IF (RT←RECTYPE(X))=LOCATION(CMON) THEN
BEGIN
STINTERP(STMCHK(CMON:CONCLUSION[X]));
ANDWLD(STMNT:OW[X],OW,OW);
END
ELSE IF RT=LOCATION(VIA) THEN
BEGIN
DEXPRSET(VIA:ACTPLACE[X],VIA:PLACE[X],E,DT,OW);
END;
END;
END;
RECURSIVE PROCEDURE DOOPERATE(RPTR(STMNT) S);
BEGIN ! Modified by RF from DOMOVE;
RPTR(EXPRN) E;
SET SEEN;
RCELL C;
RANY ONM;
RPTR(OPERATE) MS;
INTEGER DT;
ITEMVAR IW,OW;
IW←STMNT:IW[S];OW←STMNT:OW[S];
CPYWLD(IW,OW);
MS ← STMNT:SEMANTICS[S]; ! Added by RF;
SEEN←PHI;
IF OPERATE:WHAT[MS]=YHAND ∨ OPERATE:WHAT[MS]=BHAND THEN
BEGIN ! OK, Ray, you win. But this is a kluge;
E ← NULL_RECORD;
DT←SVAL_DTYPE;
OPERATE:CF[MS] ← OPERATE:WHAT[MS];
END
ELSE BUG("OPERATE MUST USE A HAND");
DEXPRSET(OPERATE:DEXP[MS],OPERATE:DEST[MS],E,DT,OW);
VCHANGE(OPERATE:CF[MS],DEXPR:VAL[OPERATE:DEXP[MS]],OW);
C←OPERATE:CLAUSES[MS];
WHILE C≠NULL_RECORD DO
BEGIN
RANY X;INTEGER RT;
X←LLOP(C);
IF (RT←RECTYPE(X))=LOCATION(CMON) THEN
BEGIN
STINTERP(STMCHK(CMON:CONCLUSION[X]));
ANDWLD(STMNT:OW[X],OW,OW);
END
ELSE IF RT=LOCATION(VIA) THEN
BEGIN
DEXPRSET(VIA:ACTPLACE[X],VIA:PLACE[X],E,DT,OW);
END;
END;
END;
! do_affix, do_affix_stmnt, do_unfix;
INTERNAL PROCEDURE DO_UNFIX(ITEMVAR OW;RVAR F1,F2;REFERENCE RCELL GPHCODE);
BEGIN
RPTR(EXPRN,VARIABLE) BYEX;
RPTR(AFXDATA) AD;
RVAR RGF;
IF LPMATCH(OW,\(AFFIXED,$ F1, $ F2,BIND BYEX,BIND RGF) ) THEN
BEGIN
DENYF(OW,_FACT_);
AD←AFXDGET(F1,F2,BYEX,FALSE);
IF RGF=RIGIDLY THEN
BEGIN
IF AFXDATA:T[AD]=BYEX THEN
BYEX←AFXDATA:INVT[AD]
ELSE
BYEX←AFXDATA:T[AD];
LPDENY(OW,\(AFFIXED,$ F2, $ F1,BYEX, RIGIDLY) );
REMCALC(OW,F1,AFXDATA:C1[AD]);
REMCALC(OW,F2,AFXDATA:C2[AD]);
CONSON(NEW_GASSIGN(F2,2,AFXDATA:C2[AD]),GPHCODE);
END
ELSE
BEGIN
RPTR(ALSODO) ADO;
REMCALC(OW,F1,AFXDATA:C1[AD]);
REMCHG(OW,F1,AFXDATA:CHG[AD]);
CONSON(NEW_ALSODO(F1,2,AFXDATA:CHG[AD]),GPHCODE);
END;
CONSON(NEW_GASSIGN(F1,2,AFXDATA:C1[AD]),GPHCODE);
END;
END;
INTERNAL PROCEDURE DO_AFFIX(ITEMVAR OW;RVAR F1,F2,BV;REXPR AE;RVAR RGF;
REFERENCE RCELL GPHCODE);
BEGIN
RANY ASTN;
RPTR(TRANS) T;
RPTR(AFXDATA) AD;
RPTR(VARIABLE) BVV;
RPTR(BLOCK) BID;
RPTR(ASSIGNMENT) ASG;
DO_UNFIX(OW,F1,F2,GPHCODE);
AD←AFXDGET(F1,F2,BV,TRUE);
IF AE=NULL_RECORD THEN
AE←NEW_EXPRN(TRANS_DTYPE,TTMUL_OP,
LIST2(NEW_EXPRN(TRANS_DTYPE,TINVRT_OP,CONS(F2,NULL_RECORD)),F1));
! FTOF(F2,F1);
VCHANGE(BV,EVALEXPR(AE,OW),OW);
BID←VARIABLE:BLK[AFXDATA:YOUNGEST[AD]];
LPASRT(OW,\(AFFIXED, $ F1, $ F2, $ BV, $ RGF));
IF AFXDATA:C1[AD]=NULL_RECORD THEN
BEGIN
AFXDATA:C1[AD]←ASGLBL(NEW_LBL(ANY,CLCLAB_DTYPE,BID),
BLDCALC(OW,NEW_EXPRN(TRANS_DTYPE,TTMUL_OP,
LIST2(F2,BV) ),BID));
END;
CONSON(NEW_GASSIGN(F1,1,AFXDATA:C1[AD]),GPHCODE);
ADDCALC(OW,F1,AFXDATA:C1[AD]);
IF RGF=RIGIDLY THEN
BEGIN
IF AFXDATA:INVT[AD]=NULL_RECORD THEN
BEGIN
AFXDATA:INVT[AD]←NEW_EXPRN(TRANS_DTYPE,
TINVRT_OP,CONS(BV,NULL_RECORD));
AFXDATA:C2[AD]←ASGLBL(NEW_LBL(ANY,CLCLAB_DTYPE,BID),
BLDCALC(OW,NEW_EXPRN(TRANS_DTYPE,TTMUL_OP,
LIST2(F1,AFXDATA:INVT[AD])),BID));
END;
CONSON(NEW_GASSIGN(F2,1,AFXDATA:C2[AD]),GPHCODE);
LPASRT(OW,\(AFFIXED, $ F2, $ F1, $ AFXDATA:INVT[AD], RIGIDLY));
ADDCALC(OW,F2,AFXDATA:C2[AD]);
END
ELSE
BEGIN
RPTR(ALSODO) ADO;
IF AFXDATA:CHG[AD]=NULL_RECORD THEN
BEGIN
RVAR FF2; ! to get around a SAIL lossage;
RPTR(ASSIGNMENT) ASG;
FF2←F2;
ASG←NEW_RECORD(ASSIGNMENT);
ASSIGNMENT:VAR[ASG]←BV;
ASSIGNMENT:VAL[ASG]←NEW_EXPRN(TRANS_DTYPE,TTMUL_OP,
LIST2(NEW_EXPRN(TRANS_DTYPE,TINVRT_OP,
CONS(FF2,NULL_RECORD)),
VNEWTRANS) );
AFXDATA:CHG[AD]←ASGLBL(NEW_LBL(ANY,CHGLAB_DTYPE,BID),
BLDCHG(STMAKE(ASG),BID));
END;
ADO←NEW_RECORD(ALSODO);
ALSODO:VAR[ADO]←F1;ALSODO:OP[ADO]←1;
ALSODO:CHG[ADO]←AFXDATA:CHG[AD];
ADDCHG(OW,F1,AFXDATA:CHG[AD]);
CONSON(ADO,GPHCODE);
END;
ASG←NEW_RECORD(ASSIGNMENT);
ASSIGNMENT:VAR[ASG]←BV;
ASSIGNMENT:VAL[ASG]←AE;
CONSON(ASG,GPHCODE);
END;
! blockdo & sttblk, blkopdo;
RECPROC BLOCKDO(RPTR(STMNT) S);
BEGIN
ITEMVAR IW;
RCELL C;
RPTR(BLOCK) OCB;
SIMPLE PROCEDURE OCBDO;CURBLK←OCB;
CLEANUP OCBDO;
OCB←CURBLK;
CURBLK←STMNT:SEMANTICS[S];
C←BLOCK:CODE[CURBLK];
IW←STMNT:IW[S];
WHILE C≠NULL_RECORD DO
BEGIN
INTEGER ST;
ST←RECTYPE(CELL:CAR[C]);
IF ST=LOC(STMNT) THEN
BEGIN
STINTERP(CELL:CAR[C]);
IW←STMNT:OW[CELL:CAR[C]];
END
ELSE IF ST=LOC(PVL) THEN
PVLDO(PVL:VL[CELL:CAR[C]],IW)
ELSE IF ST=LOC(VARIABLE) THEN
BEGIN
END
ELSE IF ST=LOC(DBD) THEN
WLDDMP(DBD:WLD[CELL:CAR[C]])
ELSE IF ST=LOC(NW) THEN
BEGIN
END
ELSE
BEGIN
USERERR(1,1,"FUNNY BLOCK ELEMENT");
END;
C←CELL:CDR[C];
END;
END;
INTERNAL RPTR(BLOCK) PROCEDURE STTBLK(RANY S);
BEGIN
RPTR(BLOCK) B;
IF RECTYPE(S)≠LOC(BLOCK) THEN
BEGIN
B←NEW_RECORD(BLOCK);
BLOCK:CODE[B]←CONS(S,NULL_RECORD);
RETURN(STMAKE(B));
END;
RETURN(S);
END;
PROCEDURE BLKOPDO(ITEMVAR W;INTEGER OP);
BEGIN
RCELL C;
CASE OP OF
BEGIN
[ENTERBLOCK] BEGIN
C←BLOCK:CLCS[CURBLK];
WHILE C≠NULL_RECORD DO
MK_CALC(W,LLOP(C));
END;
[LEAVEBLOCK] BEGIN
C←BLOCK:CLCS[CURBLK];
WHILE C≠NULL_RECORD DO
KILLCALC(W,LLOP(C));
C←BLOCK:ALSOS[CURBLK];
WHILE C≠NULL_RECORD DO
KILLCHG(W,LLOP(C));
C←BLOCK:VARS[CURBLK];
WHILE C≠NULL_RECORD DO
KILLVAR(W,LLOP(C));
END;
[0] END;
END;
! Cobdo;
RECPROC COBDO(RPTR(STMNT) S);
BEGIN
RCELL C;
BOOLEAN FLAG;
RPTR(STMNT) SS;
C←COBLOCK:CODE[CHKREC(STMNT:SEMANTICS[S],LOC(COBLOCK))];
FLAG←FALSE;
WHILE C≠NULL_RECORD DO
BEGIN
SS←STMCHK(CELL:CAR[C]);
CPYWLD(STMNT:IW[S],STMNT:IW[SS]);
STINTERP(SS);
IF FLAG THEN
MERGEIN(STMNT:OW[SS],STMNT:OW[S])
ELSE
BEGIN
FLAG←TRUE;
CPYWLD(STMNT:OW[SS],STMNT:OW[S]);
END;
C←CELL:CDR[C];
END;
IF ¬FLAG THEN
CPYWLD(STMNT:IW[S],STMNT:OW[S]);
END;
! loopbdo;
RECPROC LOOPBDO(RPTR(STMNT) S);
BEGIN
CALL_ALERT(STMNT:IW[S]);
STINTERP(S);
CHECK_GUARDS(STMNT:IW[S],STMNT:OW[S]);
END;
! statement interpreter: stinterp (owdo, iwcopy);
INTERNAL RECPROC STINTERP(RPTR(STMNT) S);
BEGIN
! Takes the statement S and interprets what it would do to
the world. The worlds associated with S are actually
modified;
INTEGER STYP;
ITEMVAR IW,OW;
RSSS SS;
RPTR(STMNT) S1,S2;
LABEL XIT,YETMORE;
PROCEDURE OWDO;
CPYWLD(IW,OW);
SIMPLE PROCEDURE IWCOPY(RPTR(STMNT) SX);
CPYWLD(IW,STMNT:IW[SX]);
IF STITRC LAND '1 THEN
$PRINT(CRLF&"STATEMENT TYPE ="&CVOS(STYP));
IF STITRC LAND '2 THEN
BEGIN
$PRINT(CRLF&"STATEMENT RECORD =");
HALPRN(S);
END;
IF S=NULL_RECORD THEN
RETURN;
IF RECTYPE(S) ≠ LOC(STMNT)
THEN BEGIN ! Added by RF;
USERERR(1,1,"STINTERP: Not a statement");
RETURN;
END;
IF ¬UNBOUND(STMNT:PRC[S]) THEN
BEGIN
DEFINE PREDICT_EFFECTS_REC "[]" = "RPEFCT";
EXTERNAL RANY PREDICT_EFFECTS_REC;
! defined in RHTREC;
REC_RESUME(STMNT:PRC[S],PREDICT_EFFECTS_REC);
RETURN;
END;
SS←STMNT:SEMANTICS[S];
IF SS=NULL_RECORD THEN RETURN;
STYP←RECTYPE(SS);
IW←STMNT:IW[S];
OW←STMNT:OW[S];
IF STYP=LOC(BLOCK) THEN
BLOCKDO(S)
ELSE IF STYP=LOC(ASSIGNMENT) THEN
BEGIN
OWDO;
VCHANGE(ASSIGNMENT:VAR[SS],
EVALEXPR(ASSIGNMENT:VAL[SS],OW),OW);
! note that this is OW now (so side effects happen);
END
ELSE IF STYP=LOC(GASSIGN) THEN
BEGIN
OWDO;
INVALIDATE(GASSIGN:VAR[SS],OW);
CASE GASSIGN:OP[SS] OF
BEGIN
[1] ADDCALC(OW,GASSIGN:VAR[SS],GASSIGN:CLC[SS]);
[2] REMCALC(OW,GASSIGN:VAR[SS],GASSIGN:CLC[SS]);
[3] USERERR(1,1,"ONLY CALC TEMPROARILY MISSING");
[0] USERERR(1,1,"ILLEGAL GRAPH ASSIGNMENT OP")
END;
END
ELSE IF STYP=LOC(IFF) THEN
BEGIN
! here need code to handle conditional;
S1←STMCHK(IFF:THN[SS]);
S2←STMCHK(IFF:ELS[SS]);
IWCOPY(S1);
IWCOPY(S2);
STINTERP(S1);
STINTERP(S2);
ANDWLD(STMNT:OW[S1],STMNT:OW[S2],OW);
END
ELSE IF STYP=LOC(COBLOCK) THEN
BEGIN
COBDO(S);
END
ELSE IF STYP=LOC(WHIL) THEN
BEGIN
S1←WHIL:BODY[SS];
IF S1≠NULL_RECORD THEN
BEGIN
S1←STMCHK(S1);
IWCOPY(S1);
LOOPBDO(S1);
ANDWLD(STMNT:OW[S1],IW,OW);
END
ELSE
OWDO;
END
ELSE IF STYP=LOC(FORR) THEN
BEGIN ! Added by RF;
S1←FORR:BODY[SS];
IF S1≠NULL_RECORD THEN
BEGIN
S1←STMCHK(S1);
IWCOPY(S1);
LOOPBDO(S1);
ANDWLD(STMNT:OW[S1],IW,OW);
END
ELSE
OWDO;
END
ELSE IF STYP=LOC(ASSERT) THEN
BEGIN
OWDO;
ASRTIT(ASSERT:FACT[SS],IW,ASSERT:WLD[SS]);
END
ELSE IF STYP=LOC(DENY) THEN
BEGIN
OWDO;
DENYIT(DENY:FACT[SS],IW,DENY:WLD[SS]);
END
ELSE IF STYP=LOC(AFFIX) THEN
BEGIN
OWDO;
AFFIX:GPHCODE[SS]←NULL_RECORD;
DO_AFFIX(OW,AFFIX:FRAME1[SS],AFFIX:FRAME2[SS],AFFIX:BYVAR[SS],
AFFIX:ATEXP[SS],AFFIX:RIGID[SS],AFFIX:GPHCODE[SS]);
END
ELSE IF STYP=LOC(UNFIX) THEN
BEGIN
OWDO;UNFIX:GPHCODE[SS]←NULL_RECORD;
DO_UNFIX(OW,UNFIX:FRAME1[SS],UNFIX:FRAME2[SS],UNFIX:GPHCODE[SS]);
END
ELSE IF STYP=LOC(BLKOP) THEN
BEGIN
OWDO;
BLKOPDO(OW,BLKOP:OP[SS]);
END
ELSE IF STYP=LOC(NW) THEN
OWDO
ELSE IF STYP = LOC(MOVE$) THEN
BEGIN "move"
DOMOVE(S);
END "move"
ELSE IF STYP = LOC(OPERATE) THEN
BEGIN "operate"
DOOPERATE(S);
END "operate"
ELSE
GO TO YETMORE; ! to get around SAILs parse stack limits
without using /R ;
GO TO XIT;
YETMORE:IF STYP = LOC(COMMNT) OR STYP = LOC(CENTER) OR STYP = LOC(STOP)
OR STYP = LOC(PRNT) THEN
BEGIN "others" ! Added by RF;
OWDO;
END "others"
ELSE IF STYP = LOC(ALSODO) THEN
BEGIN "alsodo" ! Added by RF;
OWDO;
ADDCHG(OW,ALSODO:VAR[SS],ALSODO:CHG[SS]);
END "alsodo"
ELSE IF STYP = LOC(CMON) THEN
BEGIN "cmon" ! Added by RF;
OWDO; ! Temporarily does nothing;
END "cmon"
ELSE IF STYP = LOC(EVDO) THEN
BEGIN "evdo" ! Added by RF;
OWDO; ! Temporarily does nothing;
END "evdo"
ELSE IF STYP = LOC(PROG) THEN ! added by RF;
STINTERP(PROG:CODE[SS])
ELSE
BEGIN
$PRINT(CRLF&"***");
HALPRN(SS);
USERERR(1,1," STINTERP GIVEN A STATEMENT TYPE IT CANNOT HANDLE");
END;
XIT: END;
ifcr false thenc ! proc_form interpreter: apfrm, apfrm2;
INTERNAL RECPROC APFRM(RPTR(PROC_FORM) PF;RCELL VL);
BEGIN
RCELL PFFPL;
PFFPL←PROC_FORM:FPS[PF];
WHILE PFFPL≠NULL_RECORD ∧ VL≠NULL_RECORD DO
BEGIN
VCELL:VAL[CELL:CAR[PFFPL]]←CELL:CAR[VL];
PFFPL←CELL:CDR[PFFPL];
VL←CELL:CDR[VL];
END;
STINTERP(PROC_FORM:S[PF]);
END;
INTERNAL RECPROC APFRM2(RPTR(PROC_FORM) PF;RPTR(VALU$) V1,V2);
BEGIN
RCELL PFFPL;
RPTR(VALU$) V;
PFFPL←PROC_FORM:FPS[PF];
FOR V←V1,V2 DO
BEGIN
IF PFFPL=NULL_RECORD THEN DONE;
VCELL:VAL[CELL:CAR[PFFPL]]←V;
PFFPL←CELL:CDR[PFFPL];
END;
STINTERP(PROC_FORM:S[PF]);
END;
endc
! test program;
IFCR FALSE THENC
INTERNAL PROCEDURE WMTEST;
WHILE TRUE DO
BEGIN
REQUIRE "GOBBLE.HDR[HAL,HE]" SOURCE_FILE;
INTEGER NF,F,D;
RCELL SE;
RANY ST;
RPTR(STMNT) BS;
GETFORMAT(F,D);
SETFORMAT(0,3);
SE←READ;
ST←GROVEL(SE);
BS←STTBLK(ST);
NF←TRUE;
WLDASG(BS,CURWLD,CURWLD,NF);
HALPRN(BS);
$PRINT(CRLF);
STINTERP(BS);
SETFORMAT(F,D);
END;
ENDC
END $$PRGID;